home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / interfaces / PInterface Translator / pasc-reader.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  52.5 KB  |  1,292 lines  |  [TEXT/CCL2]
  1. ;; 
  2. ;; (try to) Crunch an MPW pascal equates file into the (more or less)
  3. ;; equivalent lisp file.
  4. ;;
  5. ;; Joe Chung, Apple Computers
  6. ;; June 1990
  7. ;;
  8. ;; Change log.
  9. ;;
  10. ;; 06/02/93 bill format-deftrap outputs in lower case again (it shouldn't have done
  11. ;;               so when Joe ran it the first time, but print wasn't obeying
  12. ;;               readtable-case yet, then.
  13. ;;               JBK's changes to parse-type so that it will handle the OCE interfaces.
  14. ;; ------------- 2.1d6
  15. ;; 03/10/93 bill (ignore char) in pasc-read-asterisk
  16. ;; 05/29/92 bill :dont-output-includes keyword to translate-pasc-file.
  17. ;;               Handle ** as an operator.
  18. ;; ------------  2.0
  19. ;; 12/19/91 bill don't rely on (fboundp 'ccl::xxx-trap-macro-function) being true.
  20. ;; 12/17/91 bill alanr's addition to the 2f3c inline in generate-deftrap
  21. ;;               parse-inline makes special dispensation for $x+$y.
  22. ;;               Both of these changes are to make the QuickTime interfaces translate.
  23. ;; ------------  2.0b4 
  24. ;; 4/19/91  joe  store all *handle-tos* keys as keywords
  25. ;; 04/08/91 joe  make sure unknown types are at least keyworded. fix unknown type
  26. ;                error message bug (wasn't working before)
  27. ;; 02/22/91 bill add str32.
  28. ;----------- 2.0b1
  29. ;; 01/07/91 bill Output DEFRECORD for ARRAY types.
  30. ;; 11/16/90 joe  moved top level functions to translate.lisp, fixed a bug in 
  31. ;;               (foo, bar, bang) pasc types... now becomes unsigned-byte instead of int.
  32. ;;               *handle-table* -> *pointer-table*
  33. ;; 10/25/90 bill in translate-type-decl: output :handle with defrecord when appropriate.
  34. ;; 09/10/90 bill in format-deftrap: prefix trap-name with "_", strip comments (they
  35. ;;                  should really be output somewhere.
  36. ;;
  37. ;; To do:
  38. ;;    If a pascal record has a field named VARIANT, output "VARIANT" versus VARIANT
  39. ;;    in the Lisp DEFRECORD form.
  40.  
  41. #| 
  42. Note of apology: 
  43.  
  44. Pascal sucks. I'm not actually apologizing for that. I'm saying that
  45. I'm sorry that I didn't realize how completely awful it was until I'd already written
  46. a substantial amount of code. Hence the kludgey nature of this program. A few words
  47. of explanation might be in order for any who tries to fathom this stuff...
  48.  
  49. On tokens and symbols: I've hacked the reader a bit so that you can get four different
  50. kinds of tokens: symbols, numbers, characters, and lists. Symbols include all the normal
  51. symbols, as well as any hex or binary numbers (i.e. #x23). Numbers are just plain ol'
  52. numbers, and characters are simply characters. List tokens are only used for comments
  53. and look like: (:comment ";Comment string"). All the symbol tokens are interned in the
  54. :translate package, and when they refer to constants, or when they are hex or binary
  55. numbers, the symbols are bound to their value if possible. Thus, certain pascal compile
  56. time expressions can be evaluated (yes - buried in this code is an infix expression
  57. interpreter!). Constants are always "dollarified" by prepending a "$" character in
  58. front of the constant name. When the constant is referred to, either as part of an
  59. expression for defining another constant, or in an INLINE function declaration, the
  60. name is also prepended with "#" character so that the constant will be auto-loaded
  61. if necessary.
  62.  
  63. On spellings: Since it is desirable to keep the correct cases of the characters in 
  64. symbol and type names, I keep a hash table called *spellings* to associate the
  65. two things. Thus the symbol KAEOPENAPPLICATION has the spelling "kAEOpenApplication"ยจ.
  66.  
  67. On types: The translator maintains a table of type names and types. The types themselves
  68. are always lists and look like: (<mactype or record> <extra-info>). Records look like
  69. (<record-name> :record). The other funny things are what I call sets and ranges which
  70. correspond to pascal type expressions: (foo, bar, bang) and [2..42] respectively. Sets
  71. always have :unsigned-byte as their mactype, and ranges have :unsigned-byte or :unsigned-
  72. integer depending on the size of the range. Sets look like: 
  73. (:unsigned-byte :set (item1 item2 ... )), and ranges look like: 
  74. (:unsigned-byte :range (2 42)). We also keep track of records who have types which are
  75. handles to they record in a table called *handle-tos*. These records are generated so
  76. that their default storage is :handle.
  77.  
  78. |#
  79.  
  80.  
  81. (in-package :translate)
  82.  
  83. ; set up the readtable for pasc files...
  84. ;
  85. (defparameter *comment-column* 32)
  86.  
  87. (defvar *normal-readtable* *readtable*)
  88. (defvar *pasc-indent* 0)
  89. (defvar *pasc-readtable* (copy-readtable nil))
  90. (defvar *pasc-read-buffer* (make-array 4096 :element-type 'base-character
  91.                                      :fill-pointer 0))
  92. (defun pasc-read-comment (stream char)
  93.   (declare (ignore char))
  94.   (setf (fill-pointer *pasc-read-buffer*) 0)
  95.   (vector-push #\; *pasc-read-buffer*)
  96.   (vector-push #\space *pasc-read-buffer*)
  97.   (do ((ch (read-char stream) (read-char stream)))
  98.       ((char= ch #\}) (list :comment (copy-seq *pasc-read-buffer*)))
  99.     (vector-push ch *pasc-read-buffer*)
  100.     (when (char= ch #\newline)
  101.       (vector-push #\; *pasc-read-buffer*)
  102.       (vector-push #\space *pasc-read-buffer*))))
  103.  
  104. (defun pasc-read-paren (stream char)
  105.   (let ((next (read-char stream)))
  106.     (cond 
  107.      ((char= next #\*)
  108.       (setf (fill-pointer *pasc-read-buffer*) 0)
  109.       (vector-push #\; *pasc-read-buffer*)
  110.       (vector-push #\space *pasc-read-buffer*)
  111.       (do ((ch (read-char stream) (read-char stream))
  112.            saw-*)
  113.           ((and saw-* (char= ch #\)))
  114.            (list :comment (copy-seq *pasc-read-buffer*)))
  115.         (cond ((char= ch #\*)
  116.                (setq saw-* t))
  117.               (t
  118.                (setq saw-* nil)
  119.                (vector-push ch *pasc-read-buffer*)
  120.                (when (char= ch #\newline)
  121.                  (vector-push #\; *pasc-read-buffer*)
  122.                  (vector-push #\space *pasc-read-buffer*))))))
  123.      (t
  124.       (progn (unread-char next stream)
  125.              char)))))
  126.  
  127. (defun pasc-read-hex (stream char)
  128.   (declare (ignore char))
  129.   (let* ((number (let ((*read-base* 16)) (read stream)))
  130.          (symbol (intern (format nil "#x~x" number))))
  131.     (setf (symbol-value symbol) number)
  132.     symbol))
  133.  
  134. (defun pasc-read-binary (stream char)
  135.   (declare (ignore char))
  136.   (let* ((number (let ((*read-base* 2)) (read stream)))
  137.          (symbol (intern (format nil "#b~b" number))))
  138.     (setf (symbol-value symbol) number)
  139.     symbol))
  140.  
  141. (defun pasc-read-self (stream char)
  142.   (declare (ignore stream))
  143.   char)
  144.  
  145. (defun pasc-read-self-symbol (stream char)
  146.   (declare (ignore stream))
  147.   (intern (make-string 1 :initial-element char)))
  148.  
  149. (defun pasc-read-dot (stream char)
  150.   (declare (ignore char))
  151.   (let ((next (read-char stream)))
  152.     (cond ((char= next #\.)
  153.            :dots)
  154.           (t
  155.            (unread-char next stream)
  156.            #\.))))
  157.  
  158. (defun pasc-read-asterisk (stream char)
  159.   (declare (ignore char))
  160.   (if (eql #\* (peek-char nil stream))
  161.     (progn
  162.       (read-char stream)
  163.       '**)
  164.     '*))
  165.  
  166. (setf (readtable-case *pasc-readtable*) :preserve)
  167. (set-syntax-from-char #\# #\a *pasc-readtable* *readtable*) ; get rid of # dispatch
  168. (set-syntax-from-char #\' #\" *pasc-readtable* *readtable*) ; ' = " !
  169.  
  170. (set-macro-character #\{ 'pasc-read-comment nil *pasc-readtable*)
  171. (set-macro-character #\$ 'pasc-read-hex nil *pasc-readtable*)
  172. (set-macro-character #\% 'pasc-read-binary nil *pasc-readtable*)
  173. (set-macro-character #\; 'pasc-read-self nil *pasc-readtable*)
  174. (set-macro-character #\: 'pasc-read-self nil *pasc-readtable*)
  175. (set-macro-character #\= 'pasc-read-self nil *pasc-readtable*)
  176. (set-macro-character #\* 'pasc-read-asterisk nil *pasc-readtable*)
  177. (set-macro-character #\+ 'pasc-read-self-symbol nil *pasc-readtable*)
  178. (set-macro-character #\- 'pasc-read-self-symbol nil *pasc-readtable*)
  179. (set-macro-character #\^ 'pasc-read-self nil *pasc-readtable*)
  180. (set-macro-character #\( 'pasc-read-paren nil *pasc-readtable*)
  181. (set-macro-character #\) 'pasc-read-self nil *pasc-readtable*)
  182. (set-macro-character #\newline 'pasc-read-self nil *pasc-readtable*)
  183. (set-macro-character #\[ 'pasc-read-self nil *pasc-readtable*)
  184. (set-macro-character #\] 'pasc-read-self nil *pasc-readtable*)
  185. (set-macro-character #\] 'pasc-read-self nil *pasc-readtable*)
  186. (set-macro-character #\. 'pasc-read-dot nil *pasc-readtable*)
  187. (set-macro-character #\, 'pasc-read-self nil *pasc-readtable*)
  188.  
  189. (defmacro fill-hash-table (table &rest command-function-list)
  190.   (let ((table-sym (gensym))
  191.         setf-code)
  192.     (do ((list command-function-list (cddr list)))
  193.         ((null list))
  194.       (push `(setf (gethash ,(car list) ,table-sym) ,(cadr list))
  195.             setf-code))
  196.     `(let ((,table-sym ,table))
  197.        ,@setf-code)))
  198.  
  199. (defvar *pasc-types* (make-hash-table))
  200. (defvar *handle-tos* (make-hash-table))
  201. (defvar *spellings* (make-hash-table))
  202. (defvar *translated-files* nil)
  203. (defvar *not-in-rom* nil)
  204. (defvar *uncertain-traps* nil)
  205. (defvar *confused-traps* nil)
  206. (defvar *good-traps* 0)
  207. (defvar *bad-traps* 0)
  208. (defparameter *bad-traps-inline* t)
  209.  
  210. ; Pascal compiler constants:
  211. (defvar true 1)
  212. (defvar false 0)
  213.  
  214. ; The following "pre-defined" types are all the type defined in Types.p. We hard-code
  215. ; them in explicitely because we can't parse types.p. We make a types.lisp which
  216. ; we translate from the part of types.p which we can translate + some fixups
  217. ;
  218. (defun flush-pasc-types ()
  219.   (clrhash *pasc-types*)
  220.   (clrhash *handle-tos*)
  221.   (clrhash *spellings*)
  222.   (setq *good-traps* 0
  223.         *bad-traps* 0)
  224.   (fill-hash-table *pasc-types*
  225.                    'char '(:character)
  226.                    'boolean '(:boolean)
  227.                    'signedbyte '(:signed-byte)
  228.                    'byte '(:unsigned-byte)
  229.                    'integer '(:signed-integer)
  230.                    'oserr '(:signed-integer)
  231.                    'scriptcode '(:signed-integer)
  232.                    'langcode '(:signed-integer)
  233.                    'longint '(:signed-long)
  234.                    'integerptr '(:pointer)
  235.                    'longintptr '(:pointer)
  236.                    'Fixed '(:signed-long)
  237.                    'fixedptr '(:pointer)
  238.                    'Fract '(:signed-long)
  239.                    'fractptr '(:pointer)
  240.                    'ptr '(:pointer)
  241.                    'procptr '(:pointer)
  242.                    'handle '(:handle)
  243.                    'str255 '((:string 255))
  244.                    'Str63 '((:string 63))
  245.                    'Str32 '((:string 32))
  246.                    'Str31 '((:string 31))
  247.                    'Str27 '((:string 27))
  248.                    'Str15 '((:string 15))
  249.                    'StringPtr '((:pointer (:string 255)))
  250.                    'StringHandle '((:handle (:string 255)))
  251.                    'ostype '(:ostype)
  252.                    'ostypeptr '(:pointer)
  253.                    'ResType '(:ostype)
  254.                    'restypeptr '(:pointer)
  255.                    'point '(:point)
  256.                    'pointptr '(:pointer)
  257.                    'extended '(:invalid-type)
  258.                    'comp '(:invalid-type)
  259.                    'file '(:invalid-type)
  260.                    'object '(:invalid-type)
  261.                    'rect '(:rect :record)
  262.                    )
  263.   (setq *translated-files* (list "types")))
  264. (flush-pasc-types)
  265.  
  266. (defvar *unrecognized-types* nil)
  267. (defvar *translate-pasc-dispatch* nil)
  268. (defvar *multiple-id-hack* nil)
  269. (defvar *record-packed-hack* nil)
  270. (defvar *exported-symbols* nil)
  271.  
  272. (defvar *traps-package* :traps)
  273.  
  274. (defun translate-pasc-file 
  275.        (&key (input-path (ccl::choose-file-dialog))
  276.              (output-path
  277.               (ccl::choose-new-file-dialog
  278.                :directory (concatenate 'string  (pathname-name input-path)
  279.                                        ".lisp")
  280.                :button-string "Translate"))
  281.              dont-translate-includes
  282.              dont-output-includes)
  283.   (let ((temp-output-path (unless output-path
  284.                             (setq output-path
  285.                                   (ccl::gen-file-name input-path)))))
  286.     (unwind-protect
  287.       (translate-pasc-file-internal
  288.        input-path output-path dont-translate-includes dont-output-includes)
  289.       (when temp-output-path
  290.         (delete-file temp-output-path)))))
  291.  
  292. (defun translate-pasc-file-internal (input-path output-path dont-translate-includes
  293.                                                 dont-output-includes)
  294.   (with-open-file (istream input-path :direction :input)
  295.     (with-open-file (ostream output-path :direction :output
  296.                              :if-exists :supersede)
  297.       (let ((*readtable* *pasc-readtable*)
  298.             (*package* (find-package :translate))
  299.             (*print-case* :downcase)
  300.             (input-directory (pathname-directory (ccl::stream-pathname istream)))
  301.             (output-directory (pathname-directory (ccl::stream-pathname ostream)))
  302.             (inhibit-newline nil)
  303.             (*pasc-indent* 0)
  304.             (*unrecognized-types* nil)
  305.             (*multiple-id-hack* nil)
  306.             (*record-packed-hack* nil)
  307.             (*exported-symbols* nil))
  308.         (format t "~%; Translating: ~s" (ccl::stream-pathname istream))
  309.         (format ostream "~%(in-package :~a)" *traps-package*)
  310.         (toplevel-mode nil nil nil)
  311.         (reset-get-token)
  312.         (do ((token (get-token istream :see-newline t :errorp nil) 
  313.                     (get-token istream :see-newline t :errorp nil)))
  314.             ((null token) t)
  315.           (cond
  316.            ((eq token #\newline)
  317.             (if (zerop (ccl::stream-column ostream))
  318.               (unless inhibit-newline
  319.                 (terpri ostream)
  320.                 (setq inhibit-newline t))
  321.               (progn (terpri ostream)
  322.                      (setq inhibit-newline nil))))
  323.            ((comment-p token)
  324.             (when (find #\$ (cadr token))
  325.               (let* ((comment-text (string-upcase (cadr token)))
  326.                      (index (search "$$SHELL" comment-text))
  327.                      dir-pos filename pathname name)
  328.                 (when index
  329.                   (setq dir-pos (position #\) comment-text :start index))
  330.                   (if dir-pos
  331.                     (setq index (1+ dir-pos))
  332.                     (incf index 7))
  333.                   (setq filename (subseq comment-text index))
  334.                   (setq pathname 
  335.                         (probe-file
  336.                          (make-pathname :directory input-directory
  337.                                         :name filename
  338.                                         :defaults nil)))
  339.                   (format ostream "~%(require-interface '~a)" 
  340.                           (subseq filename 0 (position #\. filename)))
  341.                   (if pathname
  342.                     (progn
  343.                       (setq name (pathname-name pathname))
  344.                       (unless (or dont-translate-includes
  345.                                   (member name *translated-files* :test #'string-equal))
  346.                         (translate-pasc-file 
  347.                          :input-path pathname
  348.                          :output-path
  349.                          (unless dont-output-includes
  350.                            (make-pathname :directory output-directory
  351.                                           :name name
  352.                                           :type "lisp"
  353.                                           :defaults nil))
  354.                          :dont-output-includes dont-output-includes)
  355.                         (format t "~%; Continuing: ~s" 
  356.                                 (ccl::stream-pathname istream))))
  357.                     (unless dont-translate-includes
  358.                       (progn (break "~%; Warning: Can't find file ~s" filename)))))))
  359.             (format-comment ostream token))
  360.            (t
  361.             (let ((func (gethash token (car *translate-pasc-dispatch*))))
  362.               (if func
  363.                 (funcall func token istream ostream)
  364.                 (funcall (gethash :otherwise (car *translate-pasc-dispatch*))
  365.                          token istream ostream))))))
  366.         (when *exported-symbols*
  367.           (let ((*print-pretty* t))
  368.             (format ostream "~%(export '~s)" *exported-symbols*)))
  369.         (format ostream "~%(provide-interface '~a)"
  370.                 (pathname-name (ccl::stream-pathname ostream)))
  371.         (when *unrecognized-types*
  372.           (let ((rechecked nil))
  373.             (dolist (type *unrecognized-types*)
  374.               (unless (gethash type *pasc-types*)
  375.                 (push type rechecked)))
  376.             (when rechecked
  377.               (format t "~%; Error: Did not recognize these types or records: ~s"
  378.                       rechecked))))
  379.         
  380.         )                               ; end of big let
  381.       (push (pathname-name (ccl::stream-pathname istream)) *translated-files*))))
  382.  
  383. (defvar *unget-token* nil)
  384. (defun get-token (istream &key (see-newline nil) (see-comma nil) (errorp t))
  385.   (let ((token 
  386.          (if *unget-token*
  387.            (prog1 *unget-token* (setq *unget-token* nil))
  388.            (let ((new-token (read istream errorp nil)))
  389.              (when (and new-token (symbolp new-token) (not (keywordp new-token)))
  390.                (let* ((name (symbol-name new-token))
  391.                       (upcase-token (intern (string-upcase name))))
  392.                  (when (boundp new-token)
  393.                    (setf (symbol-value upcase-token)
  394.                          (symbol-value new-token)))
  395.                  (setf (gethash upcase-token *spellings*) name)
  396.                  (setq new-token upcase-token)))
  397.              new-token))))
  398.     (if (or (and (eq token #\newline) (not see-newline))
  399.             (and (eq token #\,) (not see-comma)))
  400.       (get-token istream :see-newline see-newline :see-comma see-comma :errorp errorp)
  401.       token)))
  402.  
  403. (defun unget-token (token)
  404.   (setq *unget-token* token))
  405.  
  406. (defun reset-get-token ()
  407.   (setq *unget-token* nil))
  408.  
  409. (defparameter *toplevel-dispatch* (make-hash-table))
  410. (fill-hash-table *toplevel-dispatch*
  411.                  'CONST 'const-mode
  412.                  'TYPE 'type-mode
  413.                  'FUNCTION 'translate-function
  414.                  'PROCEDURE 'translate-procedure
  415.                  :otherwise 'ignore)
  416.  
  417. (defun toplevel-mode (token istream ostream)
  418.   (declare (ignore token istream ostream))
  419.   (setq *translate-pasc-dispatch* (list *toplevel-dispatch*)))
  420.  
  421. (defun unget-toplevel-mode (token istream ostream)
  422.   (declare (ignore istream ostream))
  423.   (unget-token token)
  424.   (setq *translate-pasc-dispatch* (list *toplevel-dispatch*)))
  425.  
  426. (defun ignore (token istream ostream)
  427.   (declare (ignore token istream ostream)))
  428.  
  429. (defun parse-error (token istream ostream)
  430.   (declare (ignore istream ostream))
  431.   (error "Unexpected token ~s" token))
  432.  
  433. (defun expecting (object istream &optional (test #'eq))
  434.   (let ((token (get-token istream)))
  435.     (unless (funcall test object token)
  436.       (error "Was expecting ~s and got ~s instead" object token))))
  437.  
  438. ;
  439. ; comments
  440. ;
  441.  
  442. (defun comment-p (token)
  443.   (and (consp token)
  444.        (eq (car token) :comment)))
  445.  
  446. (defun format-comment (ostream token)
  447.   (if (plusp (ccl::stream-column ostream))
  448.     (format ostream "~v,0t~a" *comment-column* (cadr token))
  449.     (format ostream "~a" (cadr token))))
  450.  
  451.  
  452.  
  453. ;
  454. ; functions & procedures!
  455. ;
  456.  
  457. (defun translate-function (token istream ostream)
  458.   (declare (ignore token))
  459.   (let ((identifier (get-token istream))
  460.         (args (parse-function-args istream))
  461.         (returns (car (parse-type istream)))
  462.         inline)
  463.     (expecting #\; istream) ; eat the ; after the return type
  464.     (setq inline (parse-inline-code istream))
  465.     (generate-deftrap ostream identifier args returns inline)))
  466.  
  467. (defun translate-procedure (token istream ostream)
  468.   (declare (ignore token))
  469.   (let ((identifier (get-token istream))
  470.         (args (parse-procedure-args istream))
  471.         inline)
  472.     (setq inline (parse-inline-code istream))
  473.     (generate-deftrap ostream identifier args nil inline)))
  474.  
  475. (defun generate-deftrap (ostream identifier args returns inline &aux old-trap-mf trap-number)
  476.   (cond
  477.    (inline
  478.     (let ((handled-inline)
  479.           (length (length inline)))
  480.       (if (= length 1)
  481.         (generate-stack-deftrap ostream (car inline) identifier args returns inline)
  482.         (progn
  483.           (case (car inline)
  484.             (#x3eb8                   ; return the value of a global as a word
  485.              (when (and (= length 2) (null args))
  486.                (setq handled-inline t)
  487.                (format-deftrap
  488.                 ostream nil
  489.                 :no-trap `(%get-signed-word (%int-to-ptr ,(second inline)))
  490.                 identifier args
  491.                 (if returns `(:no-trap ,returns) nil)
  492.                 nil)))
  493.             (#x2eb8                   ; return the value of a global as a long
  494.              (when (and (= length 2) (null args))
  495.                (setq handled-inline t)
  496.                (format-deftrap
  497.                 ostream nil
  498.                 :no-trap `(%get-signed-long (%int-to-ptr ,(second inline)))
  499.                 identifier args
  500.                 (if returns `(:no-trap ,returns) nil)
  501.                 nil)))
  502.             (#x303c                   ; put a constant word in d0
  503.              (when (and (= length 3)
  504.                         (>= (third inline) #xa800))
  505.                (setq handled-inline t)
  506.                (format-deftrap
  507.                 ostream nil
  508.                 :stack-trap (third inline) identifier args
  509.                 (if returns `(:stack ,returns) nil)
  510.                 (nconc `(:d0 ,(second inline))
  511.                        (mapcar #'(lambda (arg-pair) (car arg-pair)) args)))))
  512.             (#x203c                   ; put a constant longword in d0
  513.              (when (and (= length 4)
  514.                         (>= (fourth inline) #xa800))
  515.                (setq handled-inline t)
  516.                (format-deftrap 
  517.                 ostream nil
  518.                 :stack-trap (fourth inline) identifier args
  519.                 (if returns `(:stack ,returns) nil)
  520.                 (nconc  `(:d0 (+ (ash ,(second inline) 16)
  521.                                  ,(third inline)))
  522.                         (mapcar #'(lambda (arg-pair) (car arg-pair)) args)))))
  523.             (#x3f3c                   ; push a constant word on the stack
  524.              (when (and (= length 3)
  525.                         (>= (third inline) #xa800))
  526.                (setq handled-inline t)
  527.                (format-deftrap 
  528.                 ostream nil
  529.                 :stack-trap (third inline) identifier args
  530.                 (if returns `(:stack ,returns) nil)
  531.                 (nconc (mapcar #'(lambda (arg-pair) (car arg-pair)) args)
  532.                        `((,(second inline) :signed-integer))))))
  533.             (#x2f3c                   ; push a constant longword on the stack
  534.              (let (where)
  535.                (when (or (and (= length 4)
  536.                               (>= (fourth inline) #xa800)
  537.                               (setq where :fourth))
  538.                          (and (= length 5)
  539.                               (>= (fifth inline) #xa800)
  540.                               (<= #x7000 (fourth inline) #x70ff)
  541.                               (setq where :fifth)))
  542.                  (setq handled-inline t)
  543.                  (format-deftrap 
  544.                   ostream nil
  545.                   :stack-trap (if (eq where :fourth) 
  546.                                 (fourth inline)
  547.                                 (fifth inline))
  548.                   identifier args
  549.                   (if returns `(:stack ,returns) nil)
  550.                   (append (when (eq where :fifth)
  551.                             `(:d0 ,(ldb (byte 8 0) (fourth inline))))
  552.                           (mapcar #'(lambda (arg-pair) (car arg-pair)) args)
  553.                           `(((+ (ash ,(second inline) 16) ,(third inline))
  554.                              :signed-longint)))))))
  555.             ((#x201f #x301f #x205f)
  556.              (let ((reg (if (member (car inline) '(#x201f #x301f)) :d0 :a0)))
  557.                (cond ((and (= length 2)  ; really a register trap... 1 arg in reg, no return
  558.                            (= (length args) 1)
  559.                            (not returns))
  560.                       (setq handled-inline t)
  561.                       (format-deftrap 
  562.                        ostream nil
  563.                        :register-trap (second inline) identifier args
  564.                        nil
  565.                        `(,reg ,(caar args))))
  566.                      ((and (= length 3)  ; really a register trap... 1 arg in reg, value in d0 
  567.                            (= (length args) 1)
  568.                            (member (third inline) '(#x2e80 #x3e80)))
  569.                       (setq handled-inline t)
  570.                       (format-deftrap 
  571.                        ostream nil
  572.                        :register-trap (second inline) identifier args
  573.                        (if returns `(:d0 ,returns) nil)
  574.                        `(,reg ,(caar args))))
  575.                      ((and (= length 3)  ; really a register trap... 2nd arg in d0, 1 arg in a0
  576.                            (= (length args) 2)
  577.                            (= (second inline) #x205f)
  578.                            (not returns))
  579.                       (setq handled-inline t)
  580.                       (format-deftrap 
  581.                        ostream nil
  582.                        :register-trap (third inline) identifier args
  583.                        nil
  584.                        `(,reg ,(caadr args) :a0 ,(caar args))))
  585.                      ((and (= length 4) ; really a register trap... 1 arg in reg, constant in d0
  586.                            ; return value in d0
  587.                            (= (length args) 1)
  588.                            (member (fourth inline) '(#x2e80 #x3e80))
  589.                            (<= #x7000 (second inline) #x70ff))
  590.                       (setq handled-inline t)
  591.                       (format-deftrap 
  592.                        ostream nil
  593.                        :register-trap (third inline) identifier args
  594.                        (if returns `(:d0 ,returns) nil)
  595.                        `(,reg ,(caar args) :d0 ,(ldb (byte 8 0) (second inline)))))
  596.                      ((and (= length 4) ; really a register trap... 2nd arg in d0, 1 arg in a0
  597.                            ; return value in d0
  598.                            (= (length args) 2)
  599.                            (member (fourth inline) '(#x2e80 #x3e80))
  600.                            (= (second inline) #x205f))
  601.                       (setq handled-inline t)
  602.                       (format-deftrap 
  603.                        ostream nil
  604.                        :register-trap (third inline) identifier args
  605.                        (if returns `(:d0 ,returns) nil)
  606.                        `(,reg ,(caadr args) :a0 ,(caar args)))))))
  607.  
  608.             (otherwise
  609.              (cond
  610.               ((and (<= #x7000 (car inline) #x70ff)   ; MOVEQ word to d0
  611.                     (= length 2)
  612.                     (>= (second inline) #xa800))
  613.                (setq handled-inline t)
  614.                (format-deftrap
  615.                 ostream nil
  616.                 :stack-trap (second inline) identifier args
  617.                 (if returns `(:stack ,returns) nil)
  618.                 (nconc `(:d0 ,(ldb (byte 8 0) (car inline)))
  619.                        (mapcar #'(lambda (arg-pair) (car arg-pair)) args)))))))
  620.           (unless handled-inline
  621.             (format t "~%; ~a is not in ROM - INLINE = ~{ #x~16,4,'0,r~}"
  622.                     identifier inline)
  623.             (format-deftrap ostream (format nil "Not in ROM - INLINE = ~{ #x~16,4,'0,r~}" 
  624.                                             inline)
  625.                             :stack-trap 0 identifier args 
  626.                             (if returns `(:stack ,returns) nil)
  627.                             nil))))))
  628.    ((setq trap-number (find-trap-number identifier))   ; do we have a trap number??
  629.     (cond
  630.      ((or (gethash identifier *register-trap-table*)
  631.           (and (setq old-trap-mf
  632.                      (old-trap-macro-function identifier))
  633.                (eq old-trap-mf (fboundp 'ccl::register-trap-macro-function))))
  634.       (generate-register-deftrap ostream trap-number identifier args returns inline))
  635.      ((or (>= trap-number #xa800)
  636.           (and old-trap-mf
  637.                (eq old-trap-mf (fboundp 'ccl::stack-trap-macro-function))))
  638.       (generate-stack-deftrap ostream trap-number identifier args returns inline))
  639.      (t
  640.       (generate-register-deftrap ostream trap-number identifier args returns inline))))
  641.    (t
  642.     (format t "~%; ~a is not in ROM" identifier)
  643.     (format-deftrap ostream "Not in ROM"
  644.                     :stack-trap 0 identifier args (if returns `(:stack ,returns) nil)
  645.                     nil))))
  646.  
  647. (defun generate-stack-deftrap (ostream trap-number identifier args returns inline)
  648.   (let ((bad-trap nil))
  649.     (cond ((null inline)
  650.            (when (eq (or (fboundp 'ccl::stack-trap-macro-function) t)
  651.                      (macro-function (intern (concatenate 'string "_" 
  652.                                                           (symbol-name identifier))
  653.                                              :ccl)))
  654.              (format t "~%; Warning. Ignoring glue for trap ~s" identifier)
  655.              (format ostream "~%; Warning. Ignoring glue for trap ~s" identifier)))
  656.           ((= (length inline) 1)
  657.            (unless (= (car inline) trap-number)
  658.              (format t "~%; Warning. Trap number ~s (~a) doesn't match INLINE ~s"
  659.                      trap-number identifier (car inline))
  660.              (format ostream "~%; Warning. Trap number ~s (~a) doesn't match INLINE ~s"
  661.                      trap-number identifier (car inline))))
  662.           (t
  663.            (format t "~%; Unrecognized INLINE code: ~s" inline)
  664.            (setq bad-trap (format nil "Unrecognized INLINE code ~s" inline))))
  665.     (format-deftrap ostream bad-trap :stack-trap trap-number identifier args
  666.                     (if returns `(:stack ,returns) nil)
  667.                     nil)))
  668.  
  669. (defun generate-register-deftrap (ostream trap-number identifier args returns inline)
  670.   (declare (ignore inline))
  671.   (let ((rtrap (gethash identifier *register-trap-table*))
  672.         bad-trap arg-registers return-register)
  673.     (cond 
  674.      (rtrap
  675.       (let ((table-args (copy-list (rtrap-entry rtrap)))
  676.             (table-return (rtrap-exit rtrap))
  677.             (missmatches nil))
  678.         (dolist (arg args)
  679.           (dolist (table-arg table-args
  680.                              (progn (push arg missmatches)
  681.                                     (push :no-match arg-registers)))
  682.             (when (args-match arg (cadr table-arg))
  683.               (push (car table-arg) arg-registers)
  684.               (setq table-args (delete table-arg table-args))
  685.               (return))))
  686.         (setq arg-registers (nreverse arg-registers))
  687.         (cond ((null missmatches))
  688.               ((= (length missmatches) 1 (length table-args))
  689.                (let ((entry (car table-args)))
  690.                  (format t "~%; Warning. Assuming that ~s matches ~s in trap ~s" 
  691.                          (cadr entry) (car missmatches) identifier)
  692.                  (format ostream "~%; Warning. Assuming that ~s matches ~s in trap ~s" 
  693.                          (cadr entry) (car missmatches) identifier)
  694.                  (setq arg-registers 
  695.                        (nsubst (car entry) :no-match arg-registers))))
  696.               (t
  697.                (format t "~%; Warning. Can't match 411 description of trap ~s!" identifier)
  698.                (setq bad-trap 
  699.                      (format nil "Can't match 411 description ~
  700.                                   ~%   Entry:~s ~%   Exit:~s" 
  701.                              (rtrap-entry rtrap) table-return))))
  702.         (setq return-register (caar table-return))
  703.         (unless (< (length table-return) 2)
  704.           (unless (and (= (length table-return) 2)
  705.                        (eq (car (second table-return)) :d0)
  706.                        (find 'result (cadr (second table-return))))
  707.             (format t "~%; Warning. Register trap ~s returns multiple values: ~s"
  708.                     identifier table-return)
  709.             (format ostream "~%; Warning. Register trap ~s returns multiple values: ~s"
  710.                     identifier table-return)))))
  711.      (t
  712.       (format t "~%; No 411 description for register trap: ~s" identifier)
  713.       (setq bad-trap "No 411 description")))
  714.     (format-deftrap ostream bad-trap :register-trap trap-number identifier args 
  715.                     (if returns `(,return-register ,returns) nil)
  716.                     (mapcan #'(lambda (arg register) (list register (car arg)))
  717.                             args arg-registers))))
  718.  
  719. (defun format-deftrap (ostream bad-trap kind trap-number identifier args return
  720.                                trap-call-args)
  721.   (setq args (remove :comment args 
  722.                      :test #'(lambda (c a) (and (listp (car a)) (eq c (caar a))))))
  723.   (setq trap-call-args (remove :comment trap-call-args
  724.                                :test #'(lambda (c a) (and (listp a) (eq c (car a))))))
  725.   (let ((*readtable* *normal-readtable*))
  726.     (cond 
  727.      (bad-trap
  728.       (incf *bad-traps*)
  729.       (unless *bad-traps-inline* (setq ostream t))
  730.       (format ostream "~%#| ~a" bad-trap))
  731.      (t
  732.       (incf *good-traps*)))
  733.     (format ostream "~%(deftrap _~a ~s~
  734.                      ~%   ~s" identifier args return)
  735.     (if (numberp trap-number)
  736.       (format ostream "~%   (~s #x~x~{ ~s~}))"
  737.               kind trap-number trap-call-args)
  738.       (format ostream "~%   (~s ~s~{ ~s~}))"
  739.               kind trap-number trap-call-args))
  740.     (when bad-trap
  741.       (format ostream "~%|#"))))
  742.  
  743.  
  744. (defun args-match (arg 411-desc)
  745.   (or (ccl::memq (car arg) 411-desc)))
  746.  
  747. (defun parse-function-args (istream &aux result var has-args)
  748.   (loop
  749.     (let ((token (get-token istream)))
  750.       (case token
  751.         (#\: 
  752.          (unless has-args
  753.            (return))
  754.          (let ((mactype (car (parse-type istream))))
  755.            (dolist (id (nreverse *multiple-id-hack*))
  756.              (push (list id (if var `(:pointer ,mactype) mactype)) result))
  757.            (setq var nil
  758.                  *multiple-id-hack* nil)))
  759.         (#\) 
  760.          (expecting #\: istream)
  761.          (return))
  762.         ((#\(  #\; ))  ; ignore left paren & semicolon
  763.         (var (setq var t))
  764.         (otherwise
  765.          (setq has-args t)
  766.          (push token *multiple-id-hack*)))))
  767.   (nreverse result))
  768.  
  769. (defun parse-procedure-args (istream &aux result var args)
  770.   (loop
  771.     (let ((token (get-token istream)))
  772.       (case token
  773.         (#\( (setq args t))
  774.         (#\; (unless args (return)))
  775.         (#\) (get-token istream) (return)) ; eat the ; after the ) first.
  776.         (var (setq var t))
  777.         (#\:
  778.          (let ((mactype (car (parse-type istream))))
  779.            (dolist (id (nreverse *multiple-id-hack*))
  780.              (push (list id (if var `(:pointer ,mactype) mactype)) result))
  781.            (setq var nil
  782.                  *multiple-id-hack* nil)))
  783.         (otherwise
  784.          (push token *multiple-id-hack*)))))
  785.   (nreverse result))
  786.  
  787. (defun parse-inline-code (istream &aux saw-inline result)
  788.   (loop
  789.     (let ((token (get-token istream)))
  790.       (cond
  791.        ((eq token 'inline) (setq saw-inline t))
  792.        ((eq token #\;) (when saw-inline (return)))
  793.        ((eq token '+)
  794.         (unless (numberp (car result))
  795.           (parse-error token istream t))
  796.         (setq token (get-token istream))
  797.         (unless (or (numberp token)
  798.                     (and (symbolp token)
  799.                          (boundp token)
  800.                          (numberp (setq token (symbol-value token)))))
  801.           (parse-error token istream t))
  802.         (incf (car result) token))
  803.        ((symbolp token)
  804.         (unless saw-inline
  805.           (unget-token token)
  806.           (return))
  807.         (cond ((boundp token)
  808.                (push (symbol-value token) result))
  809.               (t
  810.                (push (sharp-dollarify-identifier token) result))))
  811.        ((numberp token) (push token result)))))
  812.   (nreverse result))
  813.  
  814. ; Constant declarations
  815. ;
  816.  
  817. (defparameter *const-dispatch* (make-hash-table))
  818. (fill-hash-table *const-dispatch*
  819.                  'CONST 'const-mode
  820.                  'TYPE 'type-mode
  821.                  'FUNCTION 'unget-toplevel-mode
  822.                  'PROCEDURE 'unget-toplevel-mode
  823.                  'VAR 'toplevel-mode
  824.                  'END 'toplevel-mode
  825.                  'END. 'toplevel-mode
  826.                  #\; 'parse-error
  827.                  #\: 'parse-error
  828.                  :otherwise 'translate-constant-decl)
  829.  
  830. (defun const-mode (token istream ostream)
  831.   (declare (ignore token istream ostream))
  832.   (setq *translate-pasc-dispatch* (list *const-dispatch*)))
  833.  
  834. (defun dollarify-identifier (id)
  835.   (let* ((name (gethash id *spellings*))
  836.          new-id
  837.          (first-char (elt name 0)))
  838.     (if (or (eq first-char #\_)
  839.             (eq first-char #\#))
  840.       id
  841.       (progn
  842.         (setq name (concatenate 'string "$" name))
  843.         (setq new-id (intern (string-upcase name)))
  844.         (setf (gethash new-id *spellings*) name)
  845.         (when (boundp id)
  846.           (setf (symbol-value new-id) (symbol-value id)))
  847.         new-id))))
  848.  
  849. (defun sharp-dollarify-identifier (id)
  850.   (let* ((name (gethash id *spellings*))
  851.          new-id
  852.          (first-char (elt name 0)))
  853.     (if (eq first-char #\#)
  854.       id
  855.       (progn
  856.         (if (eq first-char #\_)       ; make sure that bindings come from the $'d symbol
  857.           (setq new-id (intern (string-upcase (concatenate 'string "#" name))))
  858.           (setq new-id (intern (string-upcase (concatenate 'string "#$" name)))))
  859.         (setf (gethash new-id *spellings*) name)
  860.         (when (boundp id)
  861.           (setf (symbol-value new-id) (symbol-value id)))
  862.         new-id))))
  863.  
  864. (defun translate-constant-decl (identifier istream ostream)
  865.   (expecting #\= istream)
  866.   (let ((value (fold-constants (parse-expression (get-expression-list istream)))))
  867.     (format-constant identifier value ostream)))
  868.  
  869.  
  870. (defun format-constant (identifier value ostream)
  871.   (ignore-errors
  872.    (setf (symbol-value identifier) (eval value)))
  873.   (setq identifier (dollarify-identifier identifier))
  874.   (format ostream "(defconstant ~a " (gethash identifier *spellings*))
  875.   (typecase value
  876.     (string (if (= (length value) 4)
  877.               (format ostream ":|~a|)" value)   ; assume it's an ostype
  878.               (format ostream "\"~a\")" value)))
  879.     (otherwise (format ostream "~a)" value)))
  880.   (push identifier *exported-symbols*))
  881.  
  882.  
  883. ; Type declarations
  884. ;
  885.  
  886. (defparameter *type-dispatch* (make-hash-table))
  887. (fill-hash-table *type-dispatch*
  888.                  'CONST 'const-mode
  889.                  'TYPE 'type-mode
  890.                  'FUNCTION 'unget-toplevel-mode
  891.                  'VAR 'toplevel-mode
  892.                  'PROCEDURE 'unget-toplevel-mode
  893.                  'END 'toplevel-mode
  894.                  'END. 'toplevel-mode
  895.                  #\; 'ignore
  896.                  #\: 'parse-error
  897.                  :otherwise 'translate-type-decl)
  898.  
  899. (defparameter *record-dispatch* (make-hash-table))
  900. (fill-hash-table *record-dispatch*
  901.                  'CONST 'parse-error
  902.                  'TYPE 'parse-error
  903.                  'FUNCTION 'parse-error
  904.                  'PROCEDURE 'parse-error
  905.                  'VAR 'parse-error
  906.                  #\; 'ignore
  907.                  #\: 'parse-error
  908.                  'END 'end-record
  909.                  'CASE 'translate-record-case
  910.                  :otherwise 'translate-record-field)
  911.  
  912. (defun type-mode (token istream ostream)
  913.   (declare (ignore token istream ostream))
  914.   (setq *translate-pasc-dispatch* (list *type-dispatch*)))
  915.  
  916. (defun translate-type-decl (identifier istream ostream)
  917.   (expecting #\= istream)
  918.   (let ((type (parse-type istream)))
  919.     (cond 
  920.      ((eq type :record)
  921.       (format ostream (if (gethash (ccl::make-keyword identifier) *handle-tos*)
  922.                         "(defrecord (~a :handle) "
  923.                         "(defrecord ~a ")
  924.               (gethash identifier *spellings*))
  925.       (push *record-dispatch* *translate-pasc-dispatch*)
  926.       (incf *pasc-indent* 3)
  927.       (setf (gethash identifier *pasc-types*) 
  928.             `(,(ccl::make-keyword identifier) :record)))
  929.      ((and (consp type) (consp (car type)) (eq (caar type) :array)
  930.            (dolist (idx (cddar type) t) (unless (integerp idx) (return nil))))
  931.       (format ostream (if (gethash (ccl::make-keyword identifier) *handle-tos*)
  932.                         "(defrecord (~a :handle) "
  933.                         "(defrecord ~a ")
  934.               (gethash identifier *spellings*))
  935.       (format ostream "(array ~s))" `(array ,(cadar type) ,@(cddar type)))
  936.       (setf (gethash identifier *pasc-types*) 
  937.             `(,(ccl::make-keyword identifier) :record)))
  938.      (t
  939.       (if (and (consp type)
  940.                (eq (second type) :record))
  941.         (format ostream "(%define-record :~a (find-record-descriptor ~s))"
  942.                 identifier (car type))
  943.         (format ostream "(def-mactype :~a (find-mactype ~s))"
  944.                 identifier (if (consp (car type))
  945.                              (caar type)
  946.                              (car type))))
  947.       (when (and (consp type)           ; if it's a set, define the bits as constants
  948.                  (eq (cadr type) :set))
  949.         (do ((bit 0 (1+ bit))
  950.              (items (third type) (cdr items)))
  951.             ((null items))
  952.           (format ostream "~%")
  953.           (format-constant (car items) bit ostream)))
  954.       (setf (gethash identifier *pasc-types*)
  955.             type)))))
  956.  
  957. (defun translate-record-field (identifier istream ostream)
  958.   (let ((next-token (get-token istream)))
  959.     (cond 
  960.      ((eq next-token #\:)
  961.       (let ((type (parse-type istream)))
  962.         (case (car type)
  963.           (:boolean
  964.            (when *record-packed-hack*
  965.              (format ostream "~%; ERROR!! Record field ~a declared PACKED BOOLEAN !~%" identifier)
  966.              (format t "~%ERROR!! Record field declared PACKED BOOLEAN !")))
  967.           (:unsigned-byte
  968.            (unless *record-packed-hack*
  969.              (format ostream "~%; ERROR!! Record field ~a declared Non-PACKED BYTE !~%" identifier)
  970.              (format t "~%ERROR!! Record field declared Non-PACKED BYTE !")))
  971.           (:character
  972.            (unless *record-packed-hack*
  973.              (format ostream "~%; ERROR!! Record field ~a declared Non-PACKED CHAR !~%" identifier)
  974.              (format t "~%ERROR!! Record field declared Non-PACKED CHAR !"))))
  975.         
  976.         (cond 
  977.          (*multiple-id-hack*
  978.           (dolist (id (nreverse (cons identifier *multiple-id-hack*)))
  979.             (format ostream "~v,0t(~a ~s)~%" *pasc-indent*
  980.                     (gethash id *spellings*) (car type)))
  981.           (setq *multiple-id-hack* nil))
  982.          (t
  983.           (format ostream "~v,0t(~a ~s)" *pasc-indent*
  984.                   (gethash identifier *spellings*) (car type))))))
  985.      ((comment-p next-token)
  986.       (format-comment ostream next-token)
  987.       (terpri ostream))
  988.      (t
  989.       (push identifier *multiple-id-hack*)
  990.       (translate-record-field next-token istream ostream)))))
  991.  
  992. (defun end-record (token istream ostream)
  993.   (declare (ignore token))
  994.   (expecting #\; istream)
  995.   (format ostream "~v,0t)" *pasc-indent*)
  996.   (pop *translate-pasc-dispatch*)
  997.   (decf *pasc-indent* 3)
  998.   (setq *record-packed-hack* nil))
  999.  
  1000. (defparameter *record-case-dispatch* (make-hash-table))
  1001. (fill-hash-table *record-case-dispatch*
  1002.                  'CONST 'parse-error
  1003.                  'TYPE 'parse-error
  1004.                  'FUNCTION 'parse-error
  1005.                  'PROCEDURE 'parse-error
  1006.                  'VAR 'parse-error
  1007.                  'CASE 'parse-error
  1008.                  #\( 'translate-variants
  1009.                  'END 'end-record-case
  1010.                  #\) 'end-record-case
  1011.                  :otherwise 'ignore)
  1012.  
  1013. (defun translate-record-case (token istream ostream)
  1014.   (declare (ignore token istream))
  1015.   (format ostream "~v,0t(:variant " *pasc-indent*)
  1016.   (push *record-case-dispatch* *translate-pasc-dispatch*)
  1017.   (incf *pasc-indent* 3))
  1018.  
  1019. (defun end-record-case (token istream ostream)
  1020.   (declare (ignore istream))
  1021.   (format ostream "~v,0t)" *pasc-indent*)
  1022.   (pop *translate-pasc-dispatch*)
  1023.   (decf *pasc-indent* 3)
  1024.   (unget-token token))
  1025.  
  1026. (defparameter *variant-dispatch* (make-hash-table))
  1027. (fill-hash-table *variant-dispatch*
  1028.                  'CONST 'parse-error
  1029.                  'TYPE 'parse-error
  1030.                  'FUNCTION 'parse-error
  1031.                  'PROCEDURE 'parse-error
  1032.                  'VAR 'parse-error
  1033.                  'END 'parse-error
  1034.                  #\; 'ignore
  1035.                  #\: 'parse-error
  1036.                  #\) 'end-variants
  1037.                  'CASE 'translate-record-case
  1038.                  :otherwise 'translate-record-field)
  1039.  
  1040. (defun translate-variants (token istream ostream)
  1041.   (declare (ignore token istream))
  1042.   (format ostream "~v,0t(" *pasc-indent*)
  1043.   (push *variant-dispatch* *translate-pasc-dispatch*))
  1044.  
  1045. (defun end-variants (token istream ostream)
  1046.   (declare (ignore token istream))
  1047.   (format ostream "~v,0t)" *pasc-indent*)
  1048.   (pop *translate-pasc-dispatch*))
  1049.  
  1050. (defun parse-type (istream &key (type-packed nil))
  1051.   (declare (notinline parse-type))
  1052.   (let ((token (get-token istream)))
  1053.     (case token
  1054.       (record
  1055.        (setq *record-packed-hack* type-packed)
  1056.        :record)
  1057.       (#\^
  1058.        (list
  1059.         (let ((next-thing (car (parse-type istream))))
  1060.           (if (and (consp next-thing)
  1061.                    (eq (car next-thing)
  1062.                        :pointer))
  1063.             (let ((handle-to (cadr next-thing)))
  1064.               (setf (gethash handle-to *handle-tos*) t)
  1065.               `(:handle ,handle-to))
  1066.             `(:pointer ,next-thing)))))
  1067.       (#\(
  1068.        (let* ((stuff (do ((token (get-token istream) (get-token istream))
  1069.                           rresult)
  1070.                          ((eq token #\)) (nreverse rresult))
  1071.                        (push token rresult)))
  1072.               (length-o-stuff (length stuff)))
  1073.          `(,(cond ((< length-o-stuff 9)
  1074.                    :unsigned-byte)
  1075.                   ((< length-o-stuff 17)
  1076.                    :unsigned-word)
  1077.                   (t
  1078.                    :unsigned-longint))
  1079.            :set ,stuff)))
  1080.       (set
  1081.        (expecting 'of istream)
  1082.        (parse-type istream))
  1083.       (packed
  1084.        (parse-type istream :type-packed t))
  1085.       (array
  1086.        (expecting #\[ istream)
  1087.        (let ((dimensions
  1088.               (do ((peek (get-token istream) (get-token istream))
  1089.                    (dimensions))
  1090.                   ((eq peek #\]) (nreverse dimensions))
  1091.                 (unget-token peek)
  1092.                 (let* ((size-type (parse-type istream))
  1093.                        (size
  1094.                         (ecase (cadr size-type)
  1095.                           (:set (length (caddr size-type)))
  1096.  
  1097. ; JBK don't evaluate the range, just build an expression to calculate it
  1098.                           (:range `(- ,(cadddr size-type) 
  1099.                                      ,(caddr size-type) -1)))))
  1100.  
  1101.                   (push size dimensions)))))
  1102.          (expecting 'of istream)
  1103.          (let ((mac-type (car (parse-type istream))))
  1104.            (cond (type-packed
  1105.                   (case mac-type
  1106.                     (:boolean
  1107.                      (let ((last-dim (last dimensions)))
  1108.                        (setf (car last-dim) (ceiling (car last-dim) 8))
  1109.                        (case (apply #'* dimensions)
  1110.                          (1 '(:unsigned-byte))
  1111.                          (2 '(:unsigned-integer))
  1112.                          ((3 4) '(:unsigned-longint))
  1113.                          (otherwise
  1114.                           `((:array :byte ,@dimensions))))))
  1115.                     (:character
  1116.                      (if (and (= (length dimensions)1)
  1117.                               (= (car dimensions) 4))
  1118.                        '(:ostype)
  1119.                        `((:array :character ,@dimensions))))
  1120.                     (otherwise
  1121.                      (unless (ccl:memq mac-type '(:byte :unsigned-byte :signed-byte))
  1122.                        (format t "~%Warning! PACKED array of ~s found!"
  1123.                                mac-type))
  1124.                      `((:array ,mac-type ,@dimensions)))))
  1125.                  (t
  1126.                   `((:array ,mac-type ,@dimensions)))))))
  1127.       (string
  1128.        (let ((next (get-token istream)))
  1129.          (if (eq next #\[)
  1130.            (let ((size (get-token istream)))
  1131.              (expecting #\] istream)
  1132.              `((:string ,size)))
  1133.            `((:string 255)))))
  1134.       (univ
  1135.        (parse-type istream))
  1136.       (otherwise
  1137.        (let ((next (get-token istream :see-newline t)))
  1138.          (cond ((or (ccl:memq next '(#\; #\) #\newline #\])) ; must be a type name
  1139.                     (comment-p next))
  1140.                 (unget-token next)
  1141.                 (or (gethash token *pasc-types*)
  1142.                     (prog1 (list (ccl::make-keyword token))
  1143.                       (unless (ccl:memq (ccl::make-keyword token) ccl:*record-types*)
  1144.                         (pushnew token *unrecognized-types*)))))
  1145.                (t                       ; must be a dots thingy
  1146.                 (unget-token next)
  1147.  
  1148. ; JBK - remove the "evals" from the higher-range and lower-range
  1149.  
  1150.                 (let ((lower-range (parse-expression 
  1151.                                           (cons token (get-dots-expression-list istream)))))
  1152.                   
  1153.                   (expecting :dots istream)
  1154.                   (let ((higher-range (parse-expression
  1155.                                              (get-dots-expression-list istream))))
  1156.                     
  1157.  
  1158. #|
  1159.  
  1160.  `(,(if (< (- higher-range lower-range) 256)
  1161.                          :unsigned-byte
  1162.                          :unsigned-integer)
  1163. |#
  1164. ; JBK just specify the larger of the two, -- I hope this doesn't introduce any bugs
  1165.                     `(:unsigned-integer ; <- JBK instead of the above
  1166.                       :range ,lower-range ,higher-range))))))))))
  1167.  
  1168.  
  1169. ; Expression parsing
  1170. ;
  1171.  
  1172. (defmacro make-op (lisp-op precedence)
  1173.   `(cons ',lisp-op ,precedence))
  1174.  
  1175. (defmacro lisp-op (op)
  1176.   `(car ,op))
  1177.  
  1178. (defmacro precedence (op)
  1179.   `(cdr ,op))
  1180.  
  1181.  
  1182. (defvar *operators* (make-hash-table))
  1183.  
  1184. (fill-hash-table *operators*
  1185.                  #\. (make-op bogus 10)
  1186.                  '* (make-op * 3)
  1187.                  '/ (make-op truncate 3)
  1188.                  '+ (make-op + 2)
  1189.                  '-  (make-op - 2)
  1190.                  '** (make-op expt 1))
  1191.  
  1192. (defun get-operator (op-name)
  1193.   (or (gethash op-name *operators*) 
  1194.       (error "Unrecognized operator ~s" op-name)))
  1195.  
  1196. (defun unary-operator-p (op-name)
  1197.   (ccl::memq op-name '(- +)))
  1198.  
  1199. (defun fold-constants (expr)
  1200.   (when (atom expr)
  1201.     (return-from fold-constants expr))
  1202.   (setf (cdr expr) (mapcar 'fold-constants (cdr expr)))
  1203.   (if (find-if-not #'numberp (cdr expr))
  1204.     expr
  1205.     (apply (car expr) (cdr expr))))
  1206.  
  1207. (defun parse-expression (expr)
  1208.   (cond 
  1209.    ((atom expr)
  1210.     (if (symbolp expr)
  1211.       (sharp-dollarify-identifier expr)
  1212.       expr))
  1213.    ((eq (car expr) :lisped)
  1214.     (cdr expr))
  1215.    (t
  1216.     (case (length expr)
  1217.       (1                                ; single parenthetical expression
  1218.        (parse-expression (first expr)))
  1219.       (2                                ; single unary operator expression
  1220.        (let ((op (get-operator (first expr))))
  1221.          (list (lisp-op op) (parse-expression (second expr)))))
  1222.       (3                                ; single binary operator expression
  1223.        (if (eq (second expr) #\.)
  1224.          (let ((*readtable* *normal-readtable*))
  1225.            (read-from-string (format nil "~d.~d" (first expr) (third expr))))
  1226.          (let ((op (get-operator (second expr))))
  1227.            (list (lisp-op op)
  1228.                  (parse-expression (first expr))
  1229.                  (parse-expression (third expr))))))
  1230.       (otherwise                        ; some sort of extended expression
  1231.        (cond ((unary-operator-p (first expr))  ; i.e. - 3 * 7 ...
  1232.               (let ((rest (cddr expr)))
  1233.                 (setf (cddr expr) nil)
  1234.                 (parse-expression (cons expr rest))))
  1235.              ((unary-operator-p (third expr))  ; i.e. 3 * - 7 ...
  1236.               (let* ((unary-expr (cddr expr))
  1237.                      (rest (cddr unary-expr)))
  1238.                 (setf (cddr unary-expr) nil)
  1239.                 (setf (cddr expr) (list unary-expr))
  1240.                 (parse-expression (append expr rest))))
  1241.              
  1242.              (t                         ; extended expression
  1243.               (let ((op1 (get-operator (second expr)))
  1244.                     (op2 (get-operator (fourth expr))))
  1245.                 (cond ((> (precedence op1) (precedence op2))
  1246.                        (let ((rest (cdddr expr)))
  1247.                          (setf (cdddr expr) nil)
  1248.                          (parse-expression (cons expr rest))))
  1249.                       (t
  1250.                        (list (lisp-op op1)
  1251.                              (parse-expression (first expr))
  1252.                              (parse-expression (cddr expr)))))))))))))
  1253.  
  1254. (defun get-expression-list (istream)
  1255.   (let ((expr-list nil))
  1256.     (do ((token (get-token istream) (get-token istream)))
  1257.         ((or (eq token #\;) (eq token #\))) (nreverse expr-list))
  1258.       (case token
  1259.         (sizeof
  1260.          (expecting #\( istream) ; eat the (
  1261.          (push `(:lisped record-length ,(ccl::make-keyword (get-token istream)))
  1262.                expr-list)
  1263.          (expecting #\) istream)) ; eat the )
  1264.         (#\(
  1265.          (push (get-expression-list istream) expr-list))
  1266.         (otherwise
  1267.          (push token expr-list))))))
  1268.  
  1269. (defun get-dots-expression-list (istream)
  1270.   (let ((expr-list nil))
  1271.     (do ((token (get-token istream :see-newline t :see-comma t) 
  1272.                 (get-token istream :see-newline t :see-comma t)))
  1273.         ((ccl:memq token '(#\) #\newline :dots #\] #\, #\;)) (when (ccl:memq token '(:dots #\]))
  1274.                                                                (unget-token token))
  1275.          (nreverse expr-list))
  1276.       (if (eq token #\()
  1277.         (push (get-expression-list istream) expr-list))
  1278.       (push token expr-list))))
  1279.  
  1280. #|
  1281. (defun test (string)
  1282.   (let ((*readtable* *pasc-readtable*))
  1283.     (parse-expression
  1284.      (get-expression-list (make-string-input-stream string)))))
  1285.  
  1286. (defun test2 (string)
  1287.   (let ((*readtable* *pasc-readtable*))
  1288.     (get-expression-list (make-string-input-stream string))))
  1289. |#
  1290.  
  1291. (ccl:provide :pasc-reader)
  1292.